home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / dlap.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  20KB  |  536 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30.  
  31.  
  32. (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p))
  33. (defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p))
  34.  
  35. (defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p))
  36. (defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p))
  37.  
  38.  
  39.  
  40. (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
  41.   (declare (type index   1-or-2-class)
  42.            (type boolean class-slot-p))
  43.   (let ((instance nil)
  44.     (arglist  ())
  45.     (closure-variables ())
  46.     (field (first-wrapper-cache-number-index)))               ;we need some field to do
  47.                                    ;the fast obsolete check
  48.     (ecase reader/writer
  49.       (:reader (setq instance (dfun-arg-symbol 0)
  50.              arglist  (list instance)))
  51.       (:writer (setq instance (dfun-arg-symbol 1)
  52.              arglist  (list (dfun-arg-symbol 0) instance))))
  53.     (ecase 1-or-2-class
  54.       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
  55.       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
  56.     (generating-lap closure-variables
  57.             arglist
  58.        (with-lap-registers ((inst t)                   ;reg for the instance
  59.                 (wrapper #-structure-wrapper vector       ;reg for the wrapper
  60.                      #+structure-wrapper t)
  61.                 #+structure-wrapper (cnv fixnum-vector)
  62.                 (cache-no index))               ;reg for the cache no
  63.       (let ((index cache-no)                   ;This register is used
  64.                                    ;for different values at
  65.                                    ;different times.
  66.         (slots (and (null class-slot-p)
  67.                 (allocate-register 'vector)))
  68.         (csv   (and class-slot-p
  69.                 (allocate-register t))))
  70.         (prog1 (flatten-lap
  71.              (opcode :move (operand :arg instance) inst)   ;get the instance
  72.              (opcode :std-instance-p inst 'std-instance)   ;if not either std-inst
  73.              (opcode :fsc-instance-p inst 'fsc-instance)   ;or fsc-instance then
  74.                      #+pcl-user-instances
  75.              (opcode :user-instance-p inst 'user-instance) ;if not either std-inst
  76.              (opcode :go 'trap)                   ;we lose
  77.  
  78.                      #+pcl-user-instances
  79.              (opcode :label 'user-instance)
  80.                      #+pcl-user-instances
  81.              (opcode :move (operand :user-wrapper inst) wrapper)
  82.                      #+pcl-user-instances
  83.              (and slots
  84.               (opcode :move (operand :user-slots inst) slots))
  85.                      #+pcl-user-instances
  86.              (opcode :go 'have-wrapper)
  87.  
  88.              (opcode :label 'fsc-instance)
  89.              (opcode :move (operand :fsc-wrapper inst) wrapper)
  90.              (and slots
  91.               (opcode :move (operand :fsc-slots inst) slots))
  92.              (opcode :go 'have-wrapper)
  93.  
  94.              (opcode :label 'std-instance)
  95.              (opcode :move (operand :std-wrapper inst) wrapper)
  96.              (and slots
  97.               (opcode :move (operand :std-slots inst) slots))
  98.  
  99.              (opcode :label 'have-wrapper)
  100.              #-structure-wrapper
  101.              (opcode :move (operand :cref wrapper field) cache-no)
  102.              #+structure-wrapper
  103.              (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  104.              #+structure-wrapper
  105.              (opcode :move (operand :cref cnv field) cache-no)
  106.              (opcode :izerop cache-no 'trap)           ;obsolete wrapper?
  107.  
  108.              (ecase 1-or-2-class
  109.                (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap))
  110.                (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap)))
  111.              
  112.              (if class-slot-p
  113.              (flatten-lap
  114.               (opcode :move (operand :cvar 'index) csv)
  115.               (ecase reader/writer
  116.                (:reader (emit-get-class-slot csv 'trap inst))
  117.                (:writer (emit-set-class-slot csv (car arglist) inst))))
  118.                (flatten-lap
  119.             (opcode :move (operand :cvar 'index) index)
  120.             (ecase reader/writer
  121.                (:reader (emit-get-slot slots index 'trap inst))
  122.                (:writer (emit-set-slot slots index (car arglist) inst)))))
  123.           
  124.              (opcode :label 'trap)
  125.              (emit-miss 'miss-fn))
  126.           (when slots (deallocate-register slots))
  127.           (when csv (deallocate-register csv))))))))
  128.  
  129.  
  130.  
  131. (defun emit-one-index-readers (class-slot-p)
  132.   (declare (type boolean class-slot-p))
  133.   (let ((arglist (list (dfun-arg-symbol 0))))
  134.     (generating-lap '(field cache-vector mask size index miss-fn)
  135.             arglist
  136.       (with-lap-registers ((slots vector))
  137.     (emit-dlap  arglist
  138.             '(standard-instance)
  139.             'trap
  140.             (with-lap-registers ((index index))
  141.               (flatten-lap
  142.             (opcode :move (operand :cvar 'index) index)
  143.             (if class-slot-p
  144.                 (emit-get-class-slot index 'trap slots)
  145.                 (emit-get-slot slots index 'trap))))
  146.             (flatten-lap
  147.               (opcode :label 'trap)
  148.               (emit-miss 'miss-fn))
  149.             nil
  150.             (and (null class-slot-p) (list slots)))))))
  151.  
  152. (defun emit-one-index-writers (class-slot-p)
  153.   (declare (type boolean class-slot-p))
  154.   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
  155.     (generating-lap '(field cache-vector mask size index miss-fn)
  156.             arglist
  157.       (with-lap-registers ((slots vector))
  158.     (emit-dlap arglist
  159.            '(t standard-instance)
  160.            'trap
  161.            (with-lap-registers ((index index))
  162.              (flatten-lap
  163.                (opcode :move (operand :cvar 'index) index)
  164.                (if class-slot-p
  165.                (emit-set-class-slot index (dfun-arg-symbol 0) slots)
  166.                (emit-set-slot slots index (dfun-arg-symbol 0)))))
  167.            (flatten-lap
  168.              (opcode :label 'trap)
  169.              (emit-miss 'miss-fn))
  170.            nil
  171.            (and (null class-slot-p) (list nil slots)))))))
  172.  
  173.  
  174.  
  175. (defun emit-n-n-readers ()
  176.   (let ((arglist (list (dfun-arg-symbol 0))))
  177.     (generating-lap '(field cache-vector mask size miss-fn)
  178.             arglist
  179.       (with-lap-registers ((slots vector)
  180.                (index index))
  181.     (emit-dlap arglist
  182.            '(standard-instance)
  183.            'trap
  184.            (emit-get-slot slots index 'trap)
  185.            (flatten-lap
  186.              (opcode :label 'trap)
  187.              (emit-miss 'miss-fn))
  188.            index
  189.            (list slots))))))
  190.  
  191. (defun emit-n-n-writers ()
  192.   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
  193.     (generating-lap '(field cache-vector mask size miss-fn)
  194.             arglist
  195.       (with-lap-registers ((slots vector)
  196.                (index index))
  197.     (flatten-lap
  198.       (emit-dlap arglist
  199.              '(t standard-instance)
  200.              'trap
  201.              (emit-set-slot slots index (dfun-arg-symbol 0))
  202.              (flatten-lap
  203.                (opcode :label 'trap)
  204.                (emit-miss 'miss-fn))
  205.              index
  206.              (list nil slots)))))))
  207.   
  208.  
  209.  
  210. (defun emit-checking (metatypes applyp)
  211.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
  212.     (generating-lap '(field cache-vector mask size function miss-fn)
  213.             dlap-lambda-list
  214.       (emit-dlap (remove '&rest dlap-lambda-list)
  215.          metatypes         
  216.          'trap
  217.          (with-lap-registers ((function t))
  218.            (flatten-lap
  219.              (opcode :move (operand :cvar 'function) function)
  220.              (opcode :jmp function)))
  221.          (with-lap-registers ((miss-function t))
  222.            (flatten-lap
  223.              (opcode :label 'trap)
  224.              (opcode :move (operand :cvar 'miss-fn)